home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / EDWIN / ALLCOMS1.S next >
Encoding:
Text File  |  1993-06-15  |  16.2 KB  |  458 lines
  1. ;;;
  2. ;;;     Copyright (c) 1985 Massachusetts Institute of Technology
  3. ;;;
  4. ;;;     This material was developed by the Scheme project at the
  5. ;;;     Massachusetts Institute of Technology, Department of
  6. ;;;     Electrical Engineering and Computer Science.  Permission to
  7. ;;;     copy this software, to redistribute it, and to use it for any
  8. ;;;     purpose is granted, subject to the following restrictions and
  9. ;;;     understandings.
  10. ;;;
  11. ;;;     1. Any copy made of this software must include this copyright
  12. ;;;     notice in full.
  13. ;;;
  14. ;;;     2. Users of this software agree to make their best efforts (a)
  15. ;;;     to return to the MIT Scheme project any improvements or
  16. ;;;     extensions that they make, so that these may be included in
  17. ;;;     future releases; and (b) to inform MIT of noteworthy uses of
  18. ;;;     this software.
  19. ;;;
  20. ;;;     3.  All materials developed as a consequence of the use of
  21. ;;;     this software shall duly acknowledge such use, in accordance
  22. ;;;     with the usual standards of acknowledging credit in academic
  23. ;;;     research.
  24. ;;;
  25. ;;;     4. MIT has made no warrantee or representation that the
  26. ;;;     operation of this software will be error-free, and MIT is
  27. ;;;     under no obligation to provide any services, by way of
  28. ;;;     maintenance, update, or otherwise.
  29. ;;;
  30. ;;;     5.  In conjunction with products arising from the use of this
  31. ;;;     material, there shall be no use of the name of the
  32. ;;;     Massachusetts Institute of Technology nor of any adaptation
  33. ;;;     thereof in any advertising, promotional, or sales literature
  34. ;;;     without prior written consent from MIT in each case.
  35. ;;;
  36. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  37. ;;;
  38. ;;;     Modified by Texas Instruments Inc 8/15/85
  39. ;;;
  40. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  41.  
  42. ;;; This has been done to do most of the stuff at compile time rather
  43. ;;; than at load time. The commands and key definition are combined into
  44. ;;; one.
  45. ;;;
  46. ;;; The default key needs to be the first thing defined.
  47. ;;; With the current state of edwin (with the absence of extended
  48. ;;; commands) we do not need the following files comman.scm strtab.scm
  49. ;;; nvector.scm. Some of these may be needed with extended commands.
  50. ;;; All the initial commands assume that they are first ones of their
  51. ;;; name being defined. No checks are made
  52.  
  53. ;;; instead of flooding the name space with all possible commands
  54. ;;; we define only those which are explicitly needed.
  55.  
  56. (define ^r-insert-self-command '())
  57. (define ^r-argument-digit-command '())
  58. (define ^r-forward-character-command '())
  59. (define ^r-backward-character-command '())
  60. (define ^r-negative-argument-command '())
  61. (define ^r-bad-command '())
  62. ;;;
  63.  
  64. (define alt-char (integer->char 0))
  65. (define meta-char (integer->char 27))
  66. (define ctrl-x-char (integer->char 24))
  67. (define ctrl-z-char (integer->char 26))
  68.  
  69. (define *split-screen-mode?* #F)
  70.  
  71. ;;;; Basic Commands
  72.  
  73. (define-initial-command-key ("^R Bad Command" argument)
  74.   "This command is used to capture undefined keys."
  75. (
  76. (define-initial-default-key  procedure)
  77. (set! ^r-bad-command procedure)
  78. )
  79.   (editor-error (string-append "Undefined command: "
  80.                                 (obj->string (current-command-char)))))
  81.  
  82. (define-initial-command-key ("^R Insert Self" (argument 1))
  83.   "Insert the character used to invoke this."
  84. (
  85. (define add-insert-self
  86.   (lambda (lower upper)
  87.     ((rec loop
  88.        (lambda (n)
  89.          (if (> n upper)
  90.              #F
  91.              (begin
  92.                (define-initial-key (integer->char n) procedure)
  93.                (loop (1+ n))))))
  94.      lower)))
  95.  
  96. (add-insert-self 32 40)
  97. (add-insert-self 42 47)
  98. (add-insert-self 58 64)
  99. (add-insert-self 91 127)
  100. (add-insert-self 128 254)         ;;; add new code for internationalize
  101. (set! ^r-insert-self-command procedure)
  102. )
  103.   (insert-chars (current-command-char) argument (current-point)))
  104.  
  105. (define-initial-command-key ("^R Quoted Insert" (argument 1))
  106.   "Insert the next character typed"
  107.   ((define-initial-key (integer->char 17) procedure))        ;;; C-Q
  108.   (insert-chars (editor-read-char buffer-screen) argument (current-point)))
  109.  
  110. (define (insert-newlines n)
  111.   (let ((point (current-point)))
  112.     (cond ((= n 1) (region-insert-newline! point))
  113.         ((> n 1) (region-insert-string! point (make-string n #\Newline))))))
  114.  
  115. (define (insert-chars char n point)
  116.   (cond ((= n 1) (region-insert-char! point char))
  117.         ((> n 1) (region-insert-string! point (make-string n char)))))
  118.  
  119.  
  120. (define execute-extended-chars?
  121.   #T)
  122.  
  123. (define (set-command-prompt-prefix! prefix-string)
  124.   (set-command-prompt!
  125.    (string-append-with-blanks (command-argument-prompt)
  126.                             prefix-string)))
  127.  
  128. (define-initial-command-key ("^R Prefix Character" argument)
  129.   "This is a prefix for more commands."
  130. (
  131. (define-initial-prefix-key  meta-char procedure)
  132. (define-initial-prefix-key alt-char procedure)
  133. (define-initial-prefix-key  ctrl-x-char procedure)
  134. (define-initial-prefix-key (list meta-char alt-char) procedure)
  135. )
  136.   (let ((prefix-char (current-command-char)))
  137.     (set-command-prompt-prefix!
  138.          (string-append (char->name prefix-char) " "))
  139.     (let ((char (editor-read-char (window-screen (current-window)))))
  140.          (dispatch-on-char (if (atom? prefix-char)
  141.                                (list prefix-char char)
  142.                                (append prefix-char (list char)))))))
  143.  
  144. (define-initial-command-key ("^R Meta Character" argument)
  145.   "This is a prefix for more commands."
  146. (
  147. (define-initial-prefix-key  ctrl-z-char procedure)
  148. )
  149.   (let ((prefix-char meta-char))
  150.     (set-command-prompt-prefix!
  151.          (string-append (char->name prefix-char) " "))
  152.     (let ((char (editor-read-char (window-screen (current-window)))))
  153.          (dispatch-on-char (list prefix-char char)))))
  154.  
  155.  
  156. (define-initial-command-key ("^R Scheme" argument)
  157.   "Stop Edwin and return to Scheme."
  158. (
  159. (define-initial-key  (list ctrl-x-char (integer->char 26)) procedure);;;C-X C-Z
  160. )
  161.   (save-buffer-changes (current-buffer))
  162.   (edwin-exit))
  163.  
  164. (define-initial-command-key ("^R Exit" argument)
  165.   "Stop Edwin, remove internal data structures, and return to scheme."
  166. (
  167. (define-initial-key (list ctrl-x-char (integer->char 3)) procedure) ;;;C-X C-C
  168. )
  169.   (%save-buffer-changes (current-buffer))
  170.  
  171.   ;;; the following five lines fix an error with vector index out of range
  172.   ;;; in edwin using C-X ! to split screen, then using C-X C-C to exit edwin
  173.   ;;; reenter edwin and try C-X ! then error occurs
  174.   (if *split-screen-mode?*                                  ;;; 2/14/86
  175.       (begin
  176.          (set! *split-screen-mode?* #F)
  177.          (move-editor-to-full)
  178.          (move-pcs-to-full)))
  179.  
  180.   (set! edwin-editor #!unassigned)
  181.   (edwin-exit))
  182.  
  183. (define-initial-command-key ("^R Redraw Screen" argument)
  184.   "Redraw the screen."
  185. (
  186. (define-initial-key (integer->char 12) procedure)      ;;; C-L
  187. )
  188.  (window-redraw! (current-window))
  189.  (reset-modeline-window))
  190.  
  191. (define (edwin-exit)
  192.   (restore-console-contents)
  193.   (make-pcs-status-visible)
  194.   (reset-typein-window)
  195.   (gc)
  196.   ((fluid editor-continuation) *the-non-printing-object*))
  197.  
  198.  
  199. ;;;; Command Argument Reader
  200.  
  201. ;;;; Commands
  202.  
  203. (define-initial-command-key ("^R Universal Argument" argument)
  204.   "Increments the argument multiplier and enters Autoarg mode."
  205. (
  206. (define-initial-key  (integer->char 21) procedure)      ;;; C-U
  207. )
  208.   (command-argument-increment-multiplier-exponent!)
  209.   (enter-autoargument-mode!)
  210.   (update-argument-prompt!)
  211.   (read-and-dispatch-on-char))
  212.  
  213. (define-initial-command-key ("^R Argument Digit" argument)
  214.   "Sets the numeric argument for the next command."
  215. (
  216.  (set! ^r-argument-digit-command procedure)
  217. )
  218.   (command-argument-accumulate-digit! (char-base (current-command-char)))
  219.   (update-argument-prompt!)
  220.   (read-and-dispatch-on-char))
  221.  
  222. (define-initial-command-key ("^R Negative Argument" argument)
  223.   "Negates the numeric argument for the next command."
  224. (
  225. (set! ^r-negative-argument-command procedure)
  226. )
  227.   (command-argument-negate!)
  228.   (update-argument-prompt!)
  229.   (read-and-dispatch-on-char))
  230.  
  231. (define-initial-command-key ("^R Autoargument Digit" argument)
  232.   "In Autoargument mode, sets numeric argument to the next command."
  233. (
  234. (define-initial-key  #\0 procedure)
  235. (define-initial-key  #\1 procedure)
  236. (define-initial-key  #\2 procedure)
  237. (define-initial-key  #\3 procedure)
  238. (define-initial-key  #\4 procedure)
  239. (define-initial-key  #\5 procedure)
  240. (define-initial-key  #\6 procedure)
  241. (define-initial-key  #\7 procedure)
  242. (define-initial-key  #\8 procedure)
  243. (define-initial-key  #\9 procedure)
  244. )
  245.   ((if (autoargument-mode?)
  246.        ^r-argument-digit-command
  247.        ^r-insert-self-command)
  248.    argument))
  249.  
  250. (define-initial-command-key ("^R Auto Negative Argument" argument)
  251.   "In Autoargument mode, sets numeric sign to the next command."
  252. (
  253. (define-initial-key  #\- procedure)
  254. )
  255.   ((if (and (autoargument-mode?) (command-argument-beginning?))
  256.        ^r-negative-argument-command
  257.        ^r-insert-self-command)
  258.    argument))
  259.  
  260. ;;;(define-initial-command-key ("^R Autoargument" argument)
  261. ;;;  "Used to start a command argument and enter Autoargument mode."
  262. ;;;(#F
  263. ;;;)
  264. ;;;  (%edwin-autoargument argument))
  265.  
  266. ;;;; File Commands
  267.  
  268. (define-initial-command-key ("^R Visit File" argument)
  269.   "Visit new file in selected buffer."
  270. (
  271. (define-initial-key  (list ctrl-x-char (integer->char 22)) procedure)
  272. )                                                        ;;; C-X C-V
  273.   (let ((buffer (current-buffer)))
  274.     (let ((pathname
  275.            (prompt-for-pathname "Visit File :")))
  276.       (save-buffer-changes buffer)
  277.       (read-buffer buffer pathname)))
  278.   (setup-current-buffer-read-only! argument))
  279.  
  280. (define-initial-command-key ("^R Save File" argument)
  281.   "Save visited file on disk if modified."
  282. (
  283. (define-initial-key  (list ctrl-x-char (integer->char 19)) procedure)
  284. )                                    ;;; C-X C-S
  285.   (save-file (current-buffer)))
  286.  
  287. (define-initial-command-key ("Write File" argument)
  288.   "Store buffer in specified file."
  289. (
  290. (define-initial-key  (list ctrl-x-char (integer->char 23)) procedure)
  291. )                                     ;;; C-X C-W
  292.   (let ((buffer (current-buffer)))
  293.     (write-buffer
  294.      buffer
  295.      (prompt-for-pathname "Write buffer to file :"))))
  296.  
  297. (define-initial-command-key ("Insert File" argument)
  298.   "Insert contents of file into existing text."
  299. (
  300. (define-initial-key (list ctrl-x-char (integer->char 9)) procedure)
  301. )                                         ;;; C-X C-I
  302.   (let ((pathname
  303.          (prompt-for-pathname
  304.           "Insert File :")))
  305.     (set-current-region! (insert-file (current-point) pathname))))
  306.  
  307. (define-initial-command-key ("Write Region" argument)
  308.  " Write Region to a file."
  309. (
  310. (define-initial-key (list ctrl-x-char (integer->char 16)) procedure)
  311. )                                         ;;; C-X C-P
  312.  
  313.  (let ((pathname (prompt-for-pathname "Put region into file :")))
  314.    (write-region (make-region (current-point) (current-mark)) pathname)))
  315.  
  316.  
  317.  
  318. (define-initial-command-key ("^R Newline" argument)
  319.   "Insert newline, or move onto blank line."
  320. (
  321. (define-initial-key  #\Return procedure)
  322. )
  323.   (cond ((not argument)
  324.          (if (line-end? (current-point))
  325.              (let ((m1 (line-start (current-point) 1 #F)))
  326.                (if (and m1 (line-blank? m1)
  327.                         (let ((m2 (line-start m1 1 #F)))
  328.                           (and m2 (line-blank? m2))))
  329.                    (begin (set-current-point! m1)
  330.                           (delete-horizontal-space))
  331.                    (insert-newlines 1)))
  332.              (insert-newlines 1)))
  333.         (else
  334.          (insert-newlines argument))))
  335.  
  336.  
  337. ;;;; Motion Commands
  338.  
  339. (define-initial-command-key ("^R Beginning of Line" (argument 1))
  340.   "Move point to beginning of line."
  341. (
  342. (define-initial-key  (integer->char 1) procedure)         ;;; C-A
  343. )
  344.   (set-current-point! (line-start (current-point) (-1+ argument) 'LIMIT)))
  345.  
  346. (define-initial-command-key ("^R Backward Character" (argument 1))
  347.   "Move back one character."
  348. (
  349. (define-initial-key  (integer->char 2) procedure)                ;;; C-B
  350. (define-initial-key (list alt-char (integer->char 75)) procedure);;; <-
  351. (set! ^r-backward-character-command procedure)
  352. )
  353.   (move-thing mark- argument))
  354.  
  355. (define-initial-command-key ("^R End of Line" (argument 1))
  356.   "Move point to end of line."
  357. (
  358. (define-initial-key  (integer->char 5) procedure)    ;;; C-E
  359. )
  360.   (set-current-point! (line-end (current-point) (-1+ argument) 'LIMIT)))
  361.  
  362. (define-initial-command-key ("^R Forward Character" (argument 1))
  363.   "Move forward one character."
  364. (
  365. (define-initial-key  (integer->char 6) procedure)                 ;;; C-F
  366. (define-initial-key (list alt-char (integer->char 77)) procedure) ;;; ->
  367. (set! ^r-forward-character-command procedure)
  368. )
  369.   (move-thing mark+ argument))
  370.  
  371. (define-initial-command-key ("^R Goto Beginning" argument)
  372.   "Go to beginning of buffer (leaving mark behind)."
  373. (
  374. (define-initial-key  (list meta-char #\<) procedure)  ;;; M-<
  375. )                                                     ;;; alt is blocked
  376.   (cond ((not argument)
  377.          (set-current-point! (buffer-start (current-buffer))))
  378.         ((command-argument-multiplier-only?)
  379.          (set-current-point! (buffer-end (current-buffer))))
  380.         ((and (<= 0 argument) (<= argument 10))
  381.          (set-current-point! (region-10ths (buffer-region (current-buffer))
  382.                                            argument)))))
  383.  
  384. (define-initial-command-key ("^R Goto End" argument)
  385.   "Go to end of buffer (leaving mark behind)."
  386. (
  387. (define-initial-key  (list meta-char #\>) procedure) ;;; M-> alt is blocked
  388. )
  389.   (cond ((not argument)
  390.          (set-current-point! (buffer-end (current-buffer))))
  391.         ((and (<= 0 argument) (<= argument 10)
  392.          (set-current-point! (region-10ths (buffer-region (current-buffer))
  393.                                            (- 10 argument)))))))
  394.  
  395. (define (region-10ths region n)
  396.   (mark+ (region-start region)
  397.          (quotient (* n (region-count-chars region)) 10)
  398.          #F))
  399.  
  400.  
  401. (define goal-column #F)
  402.  
  403. (define temporary-goal-column-tag
  404.   "Temporary Goal Column")
  405.  
  406. (define (current-goal-column)
  407.   (or goal-column
  408.       (command-message-receive temporary-goal-column-tag
  409.         identity-procedure
  410.         (lambda () (mark-column (current-point))))))
  411.  
  412. ;;; this is temporary as we have not put the image stuff.
  413. ;;; this redefines mark-column and make-mark-from-column in struct
  414.  
  415. (define mark-column
  416.   (lambda (mark)
  417.     (char->x (line-string (mark-line mark)) (mark-position mark))))
  418.  
  419. (define make-mark-from-column
  420.   (lambda (line column)
  421.     (let ((mark (%make-mark line (x->char (line-string line) column) #T))
  422.           (group (line-group line)))
  423.       (cond ((mark< mark (%group-start group)) (%group-start group))
  424.             ((mark> mark (%group-end group)) (%group-end group))
  425.             (else mark)))))
  426.  
  427. (define-initial-command-key ("^R Down Real Line" (argument 1))
  428.   "Move down vertically to next real line."
  429. (
  430. (define-initial-key  (integer->char 14) procedure)    ;;; C-N
  431. (define-initial-key (list alt-char (integer->char 80)) procedure)
  432. )
  433.   (let ((column (current-goal-column)))
  434.     (line-offset (mark-line (current-point))
  435.                  argument
  436.                  (lambda (line)
  437.                    (set-current-point! (make-mark-from-column line column)))
  438.                  (lambda (line)
  439.                    (let ((buffer (current-buffer)))
  440.                      (region-insert-newline! (buffer-end buffer))
  441.                      (set-current-point! (buffer-end buffer)))))
  442.     (set-command-message! temporary-goal-column-tag column)))
  443.  
  444. (define-initial-command-key ("^R Up Real Line" (argument 1))
  445.   "Move up vertically to next real line."
  446. (
  447. (define-initial-key  (integer->char 16) procedure)     ;;; C-P
  448. (define-initial-key (list alt-char (integer->char 72)) procedure)
  449. )
  450.   (let ((column (current-goal-column)))
  451.     (line-offset (mark-line (current-point))
  452.                  (- argument)
  453.                  (lambda (line)
  454.                    (set-current-point! (make-mark-from-column line column)))
  455.                  (lambda (line)
  456.                    (set-current-point! (buffer-start (current-buffer)))))
  457.     (set-command-message! temporary-goal-column-tag column)))
  458.